home *** CD-ROM | disk | FTP | other *** search
/ Amiga Collections: Franz PD / Franz PD Disk #113 (1991-01)(Amiga User Group Deutschland e.V.).zip / Franz PD Disk #113 (1991-01)(Amiga User Group Deutschland e.V.).adf / Rätsel / Krumm (.txt) < prev    next >
AmigaBASIC Source Code  |  1989-07-03  |  7KB  |  330 lines
  1.  
  2.  
  3.  
  4.  
  5.  
  6. acbmname$="Mensa"
  7. REM IF FRE(1)<30000& THEN CLEAR,,30000&                         
  8. DIM bPlane&(5), cTabWork%(32), cTabSave%(32)
  9. DECLARE FUNCTION xOpen&  LIBRARY
  10. DECLARE FUNCTION xRead&  LIBRARY
  11. DECLARE FUNCTION xWrite& LIBRARY
  12. DECLARE FUNCTION AllocMem&() LIBRARY
  13. LIBRARY "dos.library"
  14. LIBRARY "exec.library"
  15. LIBRARY "graphics.library"
  16.  
  17. loadError$ = ""
  18. GOSUB LoadACBM
  19. IF loadError$ <> "" THEN GOTO Mcleanup
  20.  IF foundCCRT AND ccrtDir% THEN
  21.    FOR kk = 0 TO nColors% -1
  22.       cTabSave%(kk) = PEEKW(colorTab&+(kk*2))   
  23.       cTabWork%(kk) = cTabSave%(kk)
  24.    NEXT
  25.     FOR kk = 0 TO 80
  26.       IF ccrtDir% = 1 THEN
  27.          GOSUB Fcycle
  28.       ELSE   
  29.          GOSUB Bcycle
  30.       END IF
  31.       CALL LoadRGB4&(sViewPort&,VARPTR(cTabWork%(0)),nColors%)
  32.       FOR de1 = 0 TO ccrtSecs& * 3000
  33.          FOR de2 = 0 TO ccrtMics& / 500
  34.          NEXT
  35.       NEXT
  36.    NEXT
  37.     CALL LoadRGB4&(sViewPort&,VARPTR(cTabSave%(0)),nColors%)
  38. END IF
  39.  
  40. Mcleanup:
  41. GOTO spielanfang: 
  42.  
  43. Mcleanup2:
  44. REM LIBRARY CLOSE
  45. IF loadError$ <> "" THEN PRINT loadError$
  46. END
  47. cTemp% = cTabWork%(ccrtEnd%)
  48. FOR jj = ccrtEnd%-1 TO ccrtStart% STEP -1
  49.    cTabWork%(jj+1) = cTabWork%(jj)
  50. NEXT
  51. cTabWork%(ccrtStart%) = cTemp%
  52. RETURN
  53.  
  54. Fcycle:  '" Farbzyklus vorwärts (forward)
  55. cTemp% = cTabWork%(ccrtStart%)
  56. FOR jj = ccrtStart%+1 TO ccrtEnd%
  57.    cTabWork%(jj-1) = cTabWork%(jj)
  58. NEXT
  59. cTabWork%(ccrtEnd%) = cTemp%
  60. RETURN
  61.  
  62.  
  63. LoadACBM:
  64. '" - Folgende Variablen müssen 
  65. '" - initialisiert sein:
  66. REM -    ACBMname$ (ACBM-Dateiname)
  67.  
  68. REM - Variablen initialisieren
  69. f$ = acbmname$
  70. fHandle& = 0
  71. mybuf& = 0
  72. foundBMHD = 0
  73. foundCMAP = 0
  74. foundCAMG = 0
  75. foundCCRT = 0
  76. foundABIT = 0
  77.  
  78. REM - aus include/libraries/dos.h
  79. REM - MODE_NEWFILE = 1006 
  80. REM - MODE_OLDFILE = 1005
  81.  
  82. filename$ = f$ + CHR$(0)
  83. fHandle& = xOpen&(SADD(filename$),1005)
  84. IF fHandle& = 0 THEN
  85.    loadError$ = "Eingabedatei nicht gefunden/lesbar."
  86.    GOTO Lcleanup
  87. END IF
  88.  
  89.  
  90. REM - Pufferspeicherplatz reservieren
  91. ClearPublic& = 65537
  92. mybufsize& = 360
  93. mybuf& = AllocMem&(mybufsize&,ClearPublic&)
  94. IF mybuf& = 0 THEN
  95.    loadError$ = "Pufferspeicherplatz nicht verfügbar."
  96.    GOTO Lcleanup
  97. END IF
  98.  
  99. inbuf& = mybuf&
  100. cbuf& = mybuf& + 120
  101. ctab& = mybuf& + 240
  102.  
  103.  
  104. REM - Eingabe sollte lauten  FORMnnnnACBM
  105. rLen& = xRead&(fHandle&,inbuf&,12)
  106. tt$ = ""
  107. FOR kk = 8 TO 11
  108.    tt% = PEEK(inbuf& + kk)
  109.    tt$ = tt$ + CHR$(tt%)
  110. NEXT
  111.  
  112. IF tt$ <> "ACBM" THEN 
  113.    loadError$ = "Keine ACBM-Grafikdatei."
  114.    GOTO Lcleanup
  115. END IF
  116.  
  117. REM - ACBM-Datei Chunk-weise lesen
  118.  
  119. ChunkLoop:
  120. REM - Chunk-Name/Länge ermitteln
  121.  rLen& = xRead&(fHandle&,inbuf&,8)
  122.  icLen& = PEEKL(inbuf& + 4)
  123.  tt$ = ""
  124.  FOR kk = 0 TO 3
  125.     tt% = PEEK(inbuf& + kk)
  126.     tt$ = tt$ + CHR$(tt%)
  127.  NEXT   
  128.     
  129. IF tt$ = "BMHD" THEN  'BitMap-Header 
  130.    foundBMHD = 1
  131.    rLen& = xRead&(fHandle&,inbuf&,icLen&)
  132.    iWidth%  = PEEKW(inbuf&)
  133.    iHeight% = PEEKW(inbuf& + 2)
  134.    iDepth%  = PEEK(inbuf& + 8)  
  135.    iCompr%  = PEEK(inbuf& + 10)
  136.    scrWidth%  = PEEKW(inbuf& + 16)
  137.    scrHeight% = PEEKW(inbuf& + 18)
  138.  
  139.    iRowBytes% = iWidth% /8
  140.    scrRowBytes% = scrWidth% / 8
  141.    nColors%  = 2^(iDepth%)
  142.  
  143.    '" - Genug Platz für Videospeicher ?
  144.    AvailRam& = FRE(-1)
  145.    NeededRam& = ((scrWidth%/8)*scrHeight%*(iDepth%+1))+5000
  146.    IF AvailRam& < NeededRam& THEN
  147.       loadError$ = "Speicherplatz reicht nicht aus."
  148.       GOTO Lcleanup
  149.    END IF
  150.  
  151.    kk = 1
  152.    IF scrWidth% > 320 THEN kk = kk + 1
  153.    IF scrHeight% > 200  THEN kk = kk + 2
  154.    SCREEN 2,scrWidth%,scrHeight%,5,1
  155.    WINDOW 2,"",,0,2
  156.    CALL freesprite (0)
  157.    REM - Adressen von Screen-Structures ermitteln
  158.    GOSUB GetScrAddrs
  159.  
  160.    REM - Schirm während Ladevorgang dunkel
  161.    CALL LoadRGB4&(sViewPort&,ctab&,nColors%)
  162.  
  163.  
  164. ELSEIF tt$ = "CMAP" THEN  'Farbpalette
  165.    foundCMAP = 1
  166.    rLen& = xRead&(fHandle&,cbuf&,icLen&)
  167.  
  168.    REM - Farbpalette aufbauen
  169.    FOR kk = 0 TO nColors% - 1
  170.       red% = PEEK(cbuf&+(kk*3))
  171.       gre% = PEEK(cbuf&+(kk*3)+1)
  172.       blu% = PEEK(cbuf&+(kk*3)+2)
  173.       regTemp% = (red%*16)+(gre%)+(blu%/16)
  174.       POKEW(ctab&+(2*kk)),regTemp%
  175.    NEXT
  176.  
  177.  
  178. ELSEIF tt$ = "CAMG" THEN 'Amiga ViewPort Modes
  179.    foundCAMG = 1
  180.    rLen& = xRead&(fHandle&,inbuf&,icLen&)
  181.    camgModes& = PEEKL(inbuf&)
  182.  
  183.  
  184. ELSEIF tt$ = "CCRT" THEN 'Graphicraft-Farbzyklus-Daten
  185.    foundCCRT = 1
  186.    rLen& = xRead&(fHandle&,inbuf&,icLen&)
  187.    ccrtDir%    = PEEKW(inbuf&)
  188.    ccrtStart%  = PEEK(inbuf& + 2)
  189.    ccrtEnd%    = PEEK(inbuf& + 3)
  190.    ccrtSecs&   = PEEKL(inbuf& + 4)
  191.    ccrtMics&   = PEEKL(inbuf& + 8)
  192.  
  193.  
  194. ELSEIF tt$ = "ABIT" THEN  'Contiguous BitMap 
  195.    foundABIT = 1
  196.  
  197.    '" - Hier werden nur volle BitMaps verarbeitet, keine 
  198.    '" - Ausschnitte wie z.B. Pinsel (Brushes).
  199.    '" - Sehr schnell, liest ganze BitPlanes.
  200.    plSize& = (scrWidth%/8) * scrHeight%
  201.    FOR pp = 0 TO iDepth% -1
  202.       rLen& = xRead&(fHandle&,bPlane&(pp),plSize&)   
  203.    NEXT
  204.  
  205.  
  206. ELSE 
  207.    REM - unbekannten Chunk-Typ lesen  
  208.    FOR kk = 1 TO icLen&
  209.       rLen& = xRead&(fHandle&,inbuf&,1)
  210.    NEXT
  211.    '" - Wenn Länge ungerade, noch 1 Byte lesen
  212.    IF (icLen& OR 1) = icLen& THEN 
  213.       rLen& = xRead&(fHandle&,inbuf&,1)
  214.    END IF
  215.       
  216. END IF
  217.  
  218.  
  219. REM - Fertig, wenn alle Chunks gelesen
  220. IF foundBMHD AND foundCMAP AND foundABIT THEN
  221.    GOTO GoodLoad
  222. END IF
  223.  
  224. REM - Lesen ok, nächsten Chunk lesen
  225. IF rLen& > 0 THEN GOTO ChunkLoop
  226.  
  227. IF rLen& < 0 THEN  ' Lesefehler
  228.    loadError$ = "Lesefehler."
  229.    GOTO Lcleanup
  230. END IF   
  231.  
  232. REM - rLen& = 0  heißt EOF (Dateiende)
  233. IF (foundBMHD=0) OR (foundABIT=0) OR (foundCMAP=0) THEN
  234.    loadError$ = "Wichtige IFF-Chunks nicht gefunden."
  235.    GOTO Lcleanup
  236. END IF
  237.  
  238.  
  239. GoodLoad:
  240. loadError$ =""
  241.  
  242. REM  Farbpalette
  243. IF foundCMAP THEN 
  244.    CALL LoadRGB4&(sViewPort&,ctab&,nColors%)
  245. END IF
  246.  
  247. Lcleanup:
  248. IF fHandle& <> 0 THEN CALL xClose&(fHandle&)
  249. IF mybuf& <> 0 THEN CALL FreeMem&(mybuf&,mybufsize&)
  250.  
  251. RETURN
  252.  
  253.  
  254. GetScrAddrs:
  255. REM - Adressen von Screen-Structures ermitteln
  256.    sWindow&   = WINDOW(7)
  257.    sScreen&   = PEEKL(sWindow& + 46)
  258.    sViewPort& = sScreen& + 44
  259.    sRastPort& = sScreen& + 84
  260.    sColorMap& = PEEKL(sViewPort& + 4)
  261.    colorTab&  = PEEKL(sColorMap& + 4)
  262.    sBitMap&   = PEEKL(sRastPort& + 4)
  263.  
  264.    REM - Screen-Parameter ermitteln
  265.    scrWidth%  = PEEKW(sScreen& + 12)
  266.    scrHeight% = PEEKW(sScreen& + 14)
  267.    scrDepth%  = PEEK(sBitMap& + 5)
  268.    nColors%   = 2^scrDepth%
  269.  
  270.    REM - Adressen der BitPlanes ermitteln
  271.    FOR kk = 0 TO scrDepth% - 1
  272.       bPlane&(kk) = PEEKL(sBitMap&+8+(kk*4))
  273.    NEXT
  274. RETURN
  275.  
  276. spielanfang:
  277.  DEFINT c-d
  278.  LINE (0,250)-(330,265),0,bf
  279.  LINE (0,235)-(25,249),12,bf
  280. koo:    
  281. LOCATE 1,1:COLOR 8,0:INPUT "Koordinate Zahl";z
  282.  IF z<>3  THEN :ELSE LOCATE 1,28:PRINT  "richtig"
  283.  IF z<>4  THEN :ELSE LOCATE 1,28:PRINT  "richtig"
  284.  IF z<3 THEN BEEP: GOTO koo
  285.  IF z>4 THEN BEEP: GOTO koo
  286. ko: 
  287.  DEFINT a-z
  288.  LOCATE 2,1:INPUT "Koordinate Buchstabe";z$
  289.  IF z$<>"d" THEN  :ELSE LOCATE 2,28:PRINT  "richtig"
  290.  IF z$<>"c" THEN  :ELSE LOCATE 2,28:PRINT  "richtig"
  291.  IF z$<"c" THEN BEEP:GOTO ko
  292.  IF z$>"d" THEN BEEP:GOTO ko
  293.   
  294.  FOR i=1 TO 4000
  295.  NEXT
  296.  LINE (140,72)-(177,80),10
  297.  LINE (121,135)-(177,151),10
  298.  COLOR 10,10
  299.  AREA(140,72):AREA(146,70):AREA(146,77):AREAFILL 
  300.   AREA(177,80):AREA(170,76):AREA(170,82):AREAFILL
  301.    AREA(121,135):AREA(127,133):AREA(127,140):AREAFILL
  302.     AREA(177,151):AREA(172,153):AREA(172,146):AREAFILL
  303.   LINE (270,200)-(305,220),7,bf
  304.   LOCATE 27,35:COLOR 5,7:PRINT "ENDE"
  305.  anfang:
  306.      ON MOUSE GOSUB mausdruck
  307.      MOUSE ON
  308.      WHILE 1 : WEND
  309.  mausdruck:
  310.      druck=MOUSE(0)
  311.      x=MOUSE(3) : y=MOUSE(4)
  312.    IF x>270 AND x<305 AND y>200 AND y<220 THEN GOSUB ende
  313.    GOTO anfang
  314. ende:
  315.  WINDOW CLOSE 1
  316.  SCREEN CLOSE 1
  317.  SYSTEM
  318.  END
  319.    
  320. '**********************************************************************
  321. ' Detlef Kornatz
  322. ' Feuerbachstraße 6
  323. ' D-4300 ESSEN 1
  324. '***********************************************************************
  325.  
  326.   
  327.   
  328.   
  329.  
  330.